Cream of the Crop 26/Cream of the Crop 26.iso/program/p063b9s.zip/UNIT/MSGPACK.PAS

Pascal/Delphi Source File | 1996-04-20 | 15KB | 524 lines

Unit MsgPack;
{╔══════════════════════════════════════════════════════════════════════════╗}
{║ Mail packer                                   Last changed: 20.04.96 SA  ║}
{║                                                                          ║}
{║                         (C) Copyright 1989-93 by                         ║}
{║       Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager        ║}
{║                                                                          ║}
{║ This source may not be given to anybody, without the written permission  ║}
{║ from The Portal Team.                                                    ║}
{╚══════════════════════════════════════════════════════════════════════════╝}
{$I POPDEFS.INC}

interface

USES Use32;

procedure PackMsg(renumber: boolean);


Implementation

uses Util, fileutil, logfile, dos, globals,
     OpDate, OpString, OproUtil, OpWindow, Opcrt, netfile, Oplarray, poptypes;

Procedure PackMsg(renumber : boolean);
type

  LASTREADType = ARRAY[1..200] of Integer;

  listerecord = record
    conf      : byte;
    maildate  : s8;
    deleted   : boolean;
    filer     : byte;
    DontTouch : Boolean;
    fP        : Longint;
    filler    : Byte;
  end;

  renumrecord = record
    board     : byte;
    oldnum    : integer;
    filler    : Byte;
  end;

  var
    outputfile,
    inputfile       : file;
    outputrec,
    inputrec        : HudsonHdrrecord;
    txtoutfile,
    txtinfile       : File;
    txtstring       : string;
    i,c             : integer;
    headers         : Oparray;
    header          : listerecord;
    Msgtab          : Oparray;
    Msg             : Renumrecord;
    AreaCount       : Word;
    astcount        : SHORTINT;
    Win             : WindowPtr;
    Area            : TmsgArea;
    AreaFile        : File;
    etrec,torec,
    x               : Listerecord;
    idxfile         : file;
    idxtofile       : file;
    idxrec          : hudsonidxrecord;
    idxtorec        : s35;
    inforec         : hudsoninforecord;
    infofile        : file;
    BasePath        : PathStr;

  Procedure SkrivAst;
  Var
    Ch : Char;
  Begin
    inc(AstCount);
    if Astcount>4 then astcount:=1;
    Case AstCount of
      1 : ch:='-';
      2 : ch:='\';
      3 : ch:='|';
      4 : ch:='/';
    end;
    win^.WFasttext(ch,1,13);
  end;


  procedure Indles;
  Begin
    NetOpenFile(inputfile,basepath+'msghdr.bbs',SizeOf(inputrec),FALSE);
    headers.init(filesize(inputfile)+1,1,sizeof(listerecord),'portal.lar',maxavail div 2,lDeleteFile,DefaultPriority);
    while not eof(inputfile) do
    begin
      NetGetRec(inputfile,inputrec,filepos(inputfile),keep,wait);
      if netioresult=0 then
      Begin
        inc(AreaCount);
        skrivast;
        header.conf:=inputrec.board;
        header.maildate:=inputrec.postdate;
        header.deleted:=(inputrec.msgattr and 1) <> 0;
        header.donttouch:=false;
        Header.FP:=Filepos(inputfile)-1;
        Headers.setA(header.FP+1,0,header);
      end
    end;
  end;

  procedure writeheader(rec : integer);
  Begin
    headers.reta(rec,0,header);
    seek(inputfile,rec);
    NetGetRec(inputfile,inputrec,filepos(inputfile),keep,wait);
    NetPutRec(Outputfile,inputrec,filesize(outputfile));
  end;


  procedure Sort(l, r: word);
  var
    i, j, y   : word;
    x         : s10;
    gem       : listerecord;

    function makekey(source : listerecord):s10;
    var
      tmp : s10;
    Begin
      tmp:=longintform('###',source.conf);
      makekey:=tmp + longintform('#####',source.fp)
    end;

  begin
    skrivast;
    i := l;
    j := r;
    Headers.reta(((l+r) DIV 2),0,gem);
    x:=makekey(gem);
    repeat
      headers.reta(i,0,gem);
      While makekey(gem) < x do
      begin
        if Headers.lasterror<>0 then break;
        inc(i);
        headers.reta(i,0,gem);
      end;
      Headers.reta(j,0,gem);
      while x < makekey(gem) do
      Begin
        if Headers.lasterror<>0 then break;
        dec(j);
        Headers.reta(j,0,gem);
      end;
      if i <= j then
      begin
        headers.reta(i,0,etrec);
        Headers.reta(j,0,torec);
        Headers.Seta(j,0,etrec);
        headers.Seta(i,0,torec);
        inc(i);
        dec(j);
      end;
    until i > j;
    if l < j then Sort(l, j);
    if i < r then Sort(i, r);
  end;


  Procedure Behandel;
  var
    Ok   : Boolean;
    counter,
    oldnext,
    Next : word;
    etrec,
    torec,
    gem  : Listerecord;

    Procedure FindBreak;
    var
      Old : Listerecord;
      x,
      i   : word;
    Begin
      x:=next;
      Headers.RetA(x,0,old);
      For i:=x to Areacount do
      Begin
        headers.reta(i,0,gem);
        if gem.conf<>Old.conf then
        begin
          next:=i;
          Break;
        end;
        if i=AreaCount then ok:=True;
      end;
    end;

    Function FindConf(conference :byte):boolean;
    var
      areas ,
      test  : integer;
      board : Byte;

    Begin
      Findconf:=false;
      areas:=0;
      while not eof(AreaFile) do
      begin
        NetGetRec(AreaFile,Area,areas,nokeep,wait);
        Val(area.directory,Board,test);
        if conference=board then
        Begin
          findconf:=true;
          break;
        end;
        inc(areas);
      end;
    end;

  Begin
    ok:=false;
    next:=1;
    NetOpenFile(areafile,startpath+PoPMsgAreaFileName,SizeOf(TMsgArea),FALSE);
    repeat
      oldnext:=next;
      FindBreak;
      Headers.retA(oldnext,0,gem);
      if findconf(gem.conf) then
      begin
        if area.msgkeep<> 0 then
        Begin
          if oldnext+area.msgkeep < next-1 then
          begin
            for counter:=oldnext to (oldnext+Area.msgkeep)-1 do
            Begin
              skrivast;
              headers.reta(counter,0,gem);
              gem.DontTouch:=True;
              Headers.SetA(Counter,0,gem);
            end;
          end
          else
          begin
            for counter:=oldnext to next-1 do
            Begin
              skrivast;
              headers.reta(counter,0,gem);
              gem.DontTouch:=True;
              Headers.SetA(Counter,0,gem);
            end;
          end;
        End;
        if area.datecount<> 0 then
        begin
          for counter:=oldnext to next-1 do
          begin
            headers.reta(counter,0,gem);
            if not gem.donttouch then
            begin
              if datestringTodate('MM-DD-YY',gem.maildate) < (today-area.datecount) then
              Begin
                skrivast;
                gem.deleted:=true;
                headers.SetA(counter,0,gem)
              end;
            end;
          end;
        end;
        if area.msgcount<> 0 then
        begin
          for counter:=next-1 downto oldnext do
          begin
            headers.reta(counter,0,gem);
            if (not gem.donttouch) and (not gem.deleted) then
            begin
              skrivast;
              if area.msgcount<=0 then
              Begin
                gem.deleted:=true;
                headers.seta(counter,0,gem)
              end
              else
                dec(area.msgcount);
            end;
          end;
        end;
      end;
    until Ok;
    if Filerec(Areafile).mode<>FmClosed then NetCloseFile(areafile);
  end;


  Procedure UpdateLastRead;

    Procedure QbbsStyle;
    Var
      Lastreadfile : file;
      lastreadrec  : LastReadType;
      boardcount   : integer;


      Function ReturnLastRead(board : byte; num : integer):integer;
      var
        MsgCounter : integer;
        gem        : renumrecord;
      Begin
        Skrivast;
        returnLastread:=0;
        for msgcounter:=1 to Areacount do
        begin
          msgtab.reta(msgcounter,0,gem);
          if (gem.oldnum=num) and (gem.board=board) then
          begin
            returnLastRead:=MsgCounter;
            Break;
          end;
        end;
      end;

    Begin
      if cfg.BBs.userfile<>'' then
      Begin
        NetOpenFile(lastreadfile,JustPathName(cfg.bbs.userfile)+'\lastread.bbs',400,false);
        if netioresult=0 then
        Begin
          While not eof(lastreadfile) do
          begin
            netread(lastreadfile,LastReadRec,keep,wait);

            for boardcount:=1 to 200 do
              lastReadRec[boardcount]:=ReturnLastRead(Boardcount,LastReadRec[Boardcount]);
            netputrec(lastreadfile,lastreadrec,filepos(lastreadfile)-1);
          end;
          netclosefile(lastreadfile);
        end;
      end;
    end;

  Begin
    Win^.Wfasttext('Upd. Lastr. ',1,2);
    case cfg.bbs.bbstype of
     1,6 : QbbsStyle;
    end;
  end;


  Procedure WriteFile;
  CONST MsgTxtMax = 5;
  TYPE
    TXTBufType = Array[1..msgtxtmax] of string;

  var
    i, newnum,
    oldstart,
    counts       : word;
    ReadCount,
    LineCount    : Byte;
    txtbuf       : ^txtbuftype;

  begin
    PopGetMem(pointer(txtbuf),sizeof(TxtBufType));
    if renumber then
      msgtab.init(areacount,1,sizeof(Renumrecord),'popmsg.lar',maxavail div 2,lDeleteFile,DefaultPriority);
    newnum:=0;
    Deletefile(basepath+'msghdr.$$$');
    Deletefile(basepath+'msgtxt.$$$');
    NetOpenFile(Outputfile,basepath+'msghdr.$$$',SizeOf(inputrec),true);
    NetOpenFile(txtinfile,basepath+'msgtxt.bbs',SizeOf(txtstring),FALSE);
    NetOpenFile(txtOutfile,basepath+'msgtxt.$$$',SizeOf(txtstring),true);
    if netioresult=0 then
    begin
      for counts:=1 to areacount do
      begin
        headers.reta(counts,0,x);
        if not x.deleted then
        Begin
          Skrivast;
          NetGetRec(inputfile,inputrec,x.fp,nokeep,wait);
          IF NetIoResult=0 THEN
          begin
            if (x.conf=inputrec.board) and (x.maildate=inputrec.postdate) then
            begin
              oldstart:=inputrec.startrec;
              inputrec.startrec:=filesize(txtoutfile);
              if renumber then
              begin
                inc(newnum);
                msg.Board:=inputrec.board;
                msg.Oldnum:=inputrec.msgnum;
                msgtab.seta(newnum,0,msg);
                inputrec.msgnum:=newnum;
              end;
              NetPutRec(Outputfile,inputrec,filesize(outputfile));
              IF NetIoResult=0 THEN
{                for I:=1 to inputrec.numrecs do
                begin
                  NetGetRec(txtinfile,txtstring,oldStart+(i-1),nokeep,wait);
                  if netioresult=0 then
                    Netputrec(txtoutfile,txtstring,filesize(txtoutfile));
                end; }
                Begin
                  readcount:=inputrec.numrecs;
                  Seek(TxtInFile,oldstart);
                  repeat
                    if readcount > msgtxtmax then
                      Linecount:=msgtxtmax
                    else
                      linecount:=readcount;
                    Blockread(TxtInFile,txtbuf^,linecount);
                    blockwrite(TxtOutFile,txtBuf^,linecount);
                    dec(Readcount,linecount);
                  until readcount=0;
                end;

            end;
          end;
        end;
        if renumber then
          areacount:=newnum;
      end;
      netclosefile(outputfile);
      netclosefile(Txtinfile);
      netclosefile(Txtoutfile);
      if netioresult=0 then
      Begin
        Deletefile(basepath+'msghdr.BBS');
        Deletefile(basepath+'msgtxt.BBS');
        renameFile(basepath+'msghdr.$$$',basepath+'msghdr.bbs');
        renameFile(basepath+'msgtxt.$$$',basepath+'msgtxt.bbs');
      end;
    end;
    PopFreeMem(pointer(txtbuf),sizeof(TxtBufType));
    if renumber then
    begin
      UpdateLastRead;
      msgtab.done;
    end;
  end;


  procedure reindex;
  begin
    Deletefile(basepath+'msgidx.bbs');
    Deletefile(basepath+'msgtoidx.bbs');
    NetOpenFile(Outputfile,basepath+'msghdr.bbs',SizeOf(inputrec),false);
    NetOpenFile(idxfile,basepath+'msgidx.bbs',SizeOf(idxrec),true);
    NetOpenFile(idxtofile,basepath+'msgtoidx.bbs',SizeOf(idxtorec),true);
    NetOpenFile(infofile,basepath+'msginfo.bbs',SizeOf(inforec),true);
    fillchar(inforec,sizeof(inforec),0);
    inforec.lowmsg:=32767;
    if netioresult=0 then
    begin
      while not eof(outputfile) do
      begin
        Skrivast;
        netread(outputfile,inputrec,nokeep,wait);
        idxrec.msgnum:=inputrec.msgnum;
        idxrec.board:=inputrec.board;
        netwrite(idxfile,idxrec);
        if (inputrec.msgattr and qbdeleted)<>0 then
          idxtorec:='* Deleted *'
        else
        begin
          if (inputrec.msgattr and qbreceived)<>0 then
            idxtorec:='* Received *'
          else
            idxtorec:=inputrec.whoto;

          if inputrec.msgnum < inforec.lowmsg then
            inforec.lowmsg:=inputrec.msgnum
          else
            if inputrec.msgnum > inforec.highmsg then
              inforec.highmsg:=inputrec.msgnum;
          inc(inforec.totalactive);
          inc(inforec.activemsgs[inputrec.board]);
        end;
        netwrite(idxtofile,idxtorec);
      end;
      netclosefile(outputfile);
      netclosefile(idxfile);
      netclosefile(idxtofile);
      netwrite(infofile,inforec);
      netclosefile(infofile);
    end;
  end;

Begin
  areaCount:=0;
  MyWin(win,10,10,24,13,2,'Msg.Pack',true);
  NetOpenFile(areafile,startpath+PoPMsgAreaFileName,SizeOf(TMsgArea),FALSE);
  NetRead(areafile,area,Nokeep,wait);
  IF POS('\',Area.Directory)>0 THEN
  BEGIN
    i:=LENGTH(Area.Directory);
    WHILE Area.Directory[i]<>'\' DO
      DEC(i);
    BasePath:=COPY(Area.Directory,1,i);
  END ELSE
    BasePath:=StartPath;

  NetcloseFile(areafile);
  NetOpenFile(infofile,basepath+'msginfo.bbs',SizeOf(inforec),true);
  netread(infofile,inforec,nokeep,wait);
  netclosefile(infofile);
  if (cfg.mailscanner.renumthresh>0) and (inforec.highmsg >= Cfg.MailScanner.RenumThresh) then
    renumber:=True;
  Win^.Wfasttext('Reading  ',1,2);
  Indles;
  Win^.Wfasttext('Sorting  ',1,2);
  sort(1,areacount);
  Win^.Wfasttext('Working  ',1,2);
  Behandel;
  Win^.Wfasttext('Packing  ',1,2);
  WriteFile;
  Headers.done;
  Win^.Wfasttext('Indexing ',1,2);
  reindex;
  KillWindow(win);
end;

end.